home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / gs24src.zip / ISCAN.C < prev    next >
C/C++ Source or Header  |  1992-02-15  |  25KB  |  836 lines
  1. /* Copyright (C) 1989, 1990, 1991 Aladdin Enterprises.  All rights reserved.
  2.    Distributed by Free Software Foundation, Inc.
  3.  
  4. This file is part of Ghostscript.
  5.  
  6. Ghostscript is distributed in the hope that it will be useful, but
  7. WITHOUT ANY WARRANTY.  No author or distributor accepts responsibility
  8. to anyone for the consequences of using it or for whether it serves any
  9. particular purpose or works at all, unless he says so in writing.  Refer
  10. to the Ghostscript General Public License for full details.
  11.  
  12. Everyone is granted permission to copy, modify and redistribute
  13. Ghostscript, but only under the conditions described in the Ghostscript
  14. General Public License.  A copy of this license is supposed to have been
  15. given to you along with Ghostscript so you can know your rights and
  16. responsibilities.  It should be in a file named COPYING.  Among other
  17. things, the copyright notice and this notice must be preserved on all
  18. copies.  */
  19.  
  20. /* iscan.c */
  21. /* Token scanner for Ghostscript interpreter */
  22. #include <ctype.h>
  23. #include "memory_.h"
  24. #include "ghost.h"
  25. #include "alloc.h"
  26. #include "dict.h"            /* for //name lookup */
  27. #include "errors.h"
  28. #include "iutil.h"
  29. #include "name.h"
  30. #include "ostack.h"            /* for accumulating proc bodies */
  31. #include "packed.h"
  32. #include "store.h"
  33. #include "stream.h"
  34. #include "scanchar.h"
  35.  
  36. /* Array packing flag */
  37. ref array_packing;            /* t_boolean */
  38. /* Binary object format flag. This will never be set non-zero */
  39. /* unless the binary token feature is enabled. */
  40. ref binary_object_format;        /* t_integer */
  41. #define recognize_btokens() (binary_object_format.value.intval != 0)
  42.  
  43. /* Procedure for binary tokens.  Set at initialization if the binary token */
  44. /* option is included; only called if recognize_btokens() is true. */
  45. /* Returns 0 on success, <0 on failure. */
  46. int (*scan_btoken_proc)(P3(stream *, ref *, int)) = NULL;
  47.  
  48. /*
  49.  * Level 2 includes some changes in the scanner:
  50.  *    - \ is always recognized in strings, regardless of the data source;
  51.  *    - << and >> are legal tokens;
  52.  *    - <~ introduces an ASCII-85 encoded string (terminated by ~>)
  53.  *        (not implemented yet);
  54.  *    - Character codes above 127 introduce binary objects.
  55.  * We explicitly enable or disable these changes here.
  56.  */
  57. int scan_enable_level2 = 1;
  58.  
  59. /* Forward references */
  60. private    int    scan_hex_string(P2(stream *, ref *)),
  61.         scan_int(P6(byte **, byte *, int, int, long *, double *)),
  62.         scan_number(P3(byte *, byte *, ref *)),
  63.         scan_string(P3(stream *, int, ref *));
  64.  
  65. /* Define the character scanning table (see scanchar.h). */
  66. byte scan_char_array[258];
  67.  
  68. /* A structure for dynamically growable objects */
  69. typedef struct dynamic_area_s {
  70.     byte *base;
  71.     byte *next;
  72.     uint num_elts;
  73.     uint elt_size;
  74.     int is_dynamic;            /* false if using fixed buffer */
  75.     byte *limit;
  76. } dynamic_area;
  77. typedef dynamic_area _ss *da_ptr;
  78.  
  79. /* Begin a dynamic object. */
  80. /* dynamic_begin returns the value of alloc, which may be 0: */
  81. /* the invoker of dynamic_begin must test the value against 0. */
  82. #define dynamic_begin(pda, dnum, desize)\
  83.     ((pda)->base = (byte *)alloc((pda)->num_elts = (dnum),\
  84.                      (pda)->elt_size = (desize), "scanner"),\
  85.      (pda)->limit = (pda)->base + (dnum) * (desize),\
  86.      (pda)->is_dynamic = 1,\
  87.      (pda)->next = (pda)->base)
  88.  
  89. /* Free a dynamic object. */
  90. private void
  91. dynamic_free(da_ptr pda)
  92. {    if ( pda->is_dynamic )
  93.         alloc_free((char *)(pda->base), pda->num_elts, pda->elt_size,
  94.                "scanner");
  95. }
  96.  
  97. /* Grow a dynamic object. */
  98. /* If the allocation fails, free the old contents, and return NULL; */
  99. /* otherwise, return the new `next' pointer. */
  100. private byte *
  101. dynamic_grow(register da_ptr pda, byte *next)
  102. {    if ( next != pda->limit ) return next;
  103.     pda->next = next;
  104.        {    uint num = pda->num_elts;
  105.         uint old_size = num * pda->elt_size;
  106.         uint pos = pda->next - pda->base;
  107.         uint new_size = (old_size < 10 ? 20 :
  108.                  old_size >= (max_uint >> 1) ? max_uint :
  109.                  old_size << 1);
  110.         uint new_num = new_size / pda->elt_size;
  111.         if ( pda->is_dynamic )
  112.            {    byte *base = alloc_grow(pda->base, num, new_num, pda->elt_size, "scanner");
  113.             if ( base == 0 )
  114.                {    dynamic_free(pda);
  115.                 return NULL;
  116.                }
  117.             pda->base = base;
  118.             pda->num_elts = new_num;
  119.             pda->limit = pda->base + new_size;
  120.            }
  121.         else
  122.            {    byte *base = pda->base;
  123.             if ( !dynamic_begin(pda, new_num, pda->elt_size) ) return NULL;
  124.             memcpy(pda->base, base, old_size);
  125.             pda->is_dynamic = 1;
  126.            }
  127.         pda->next = pda->base + pos;
  128.        }
  129.     return pda->next;
  130. }
  131.  
  132. /* Initialize the scanner. */
  133. void
  134. scan_init()
  135. {    /* Initialize decoder array */
  136.     register byte _ds *decoder = scan_char_decoder;
  137.     static char stop_chars[] = "()<>[]{}/%";
  138.     static char space_chars[] = " \f\t\n\r";
  139.     decoder[ERRC] = ctype_eof;    /* ****** FIX THIS? ****** */
  140.     decoder[EOFC] = ctype_eof;
  141.     memset(decoder, ctype_name, 256);
  142.     memset(decoder + 128, ctype_btoken, 32);
  143.        {    register char _ds *p;
  144.         for ( p = space_chars; *p; p++ )
  145.           decoder[*p] = ctype_space;
  146.         decoder[char_NULL] = decoder[char_VT] =
  147.           decoder[char_DOS_EOF] = ctype_space;
  148.         for ( p = stop_chars; *p; p++ )
  149.           decoder[*p] = ctype_other;
  150.        }
  151.        {    register int i;
  152.         for ( i = 0; i < 10; i++ )
  153.           decoder['0' + i] = i;
  154.         for ( i = 0; i < max_radix - 10; i++ )
  155.           decoder['A' + i] = decoder['a' + i] = i + 10;
  156.        }
  157.     /* Other initialization */
  158.     make_false(&array_packing);
  159.     make_int(&binary_object_format, 0);
  160. }
  161.  
  162. /* Read a token from a stream. */
  163. /* Return 1 for end-of-stream, 0 if a token was read, */
  164. /* or a (negative) error code. */
  165. /* If the token required a terminating character (i.e., was a name or */
  166. /* number) and the next character was whitespace, read and discard */
  167. /* that character: see the description of the 'token' operator on */
  168. /* p. 232 of the Red Book. */
  169. /* from_string indicates reading from a string vs. a file, */
  170. /* because \ escapes are not recognized in the former case. */
  171. /* (See the footnote on p. 23 of the Red Book.) */
  172. int
  173. scan_token(register stream *s, int from_string, ref *pref)
  174. {    ref *myref = pref;
  175.     dynamic_area proc_da;    /* (not actually dynamic) */
  176.     int pstack = 0;        /* offset from proc_da.base */
  177.     int retcode = 0;
  178.     register int c;
  179.     int name_type;        /* number of /'s preceding */
  180.     int try_number;
  181.     byte s1[2];
  182.     register byte _ds *decoder = scan_char_decoder;
  183.     /* Only old P*stScr*pt interpreters use from_string.... */
  184.     from_string &= !scan_enable_level2;
  185. top:    c = sgetc(s);
  186. #ifdef DEBUG
  187. if ( gs_debug['s'] )
  188.     fprintf(gs_debug_out, (c >= 32 && c <= 126 ? "`%c'" : "`%03o'"), c);
  189. #endif
  190.     switch ( c )
  191.        {
  192.     case ' ': case '\f': case '\t': case '\n': case '\r':
  193.     case char_NULL: case char_VT: case char_DOS_EOF:
  194.         goto top;
  195.     case '[':
  196.     case ']':
  197.         s1[0] = (byte)c;
  198.         name_ref(s1, 1, myref, 1);
  199.         r_set_attrs(myref, a_executable);
  200.         break;
  201.     case '<':
  202.         if ( scan_enable_level2 )
  203.            {    c = sgetc(s);
  204.             if ( c != EOFC ) sputback(s);
  205.             switch ( c )
  206.                {
  207.             case '<':
  208.                 name_type = try_number = 0;
  209.                 goto try_funny_name;
  210.             /****** Check for <~ here ******/
  211.                }
  212.            }
  213.         retcode = scan_hex_string(s, myref);
  214.         break;
  215.     case '(':
  216.         retcode = scan_string(s, from_string, myref);
  217.         break;
  218.     case '{':
  219.         if ( pstack == 0 )
  220.            {    /* Use the operand stack to accumulate procedures. */
  221.             myref = osp + 1;
  222.             proc_da.base = (byte *)myref;
  223.             proc_da.limit = (byte *)(ostop + 1);
  224.             proc_da.is_dynamic = 0;
  225.             proc_da.elt_size = sizeof(ref);
  226.             proc_da.num_elts = ostop - osp;
  227.            }
  228.         if ( proc_da.limit - (byte *)myref < 2 * sizeof(ref) )
  229.           return e_limitcheck; /* ****** SHOULD GROW OSTACK ****** */
  230.         r_set_size(myref, pstack);
  231.         myref++;
  232.         pstack = (byte *)myref - proc_da.base;
  233.         goto top;
  234.     case '>':
  235.         if ( scan_enable_level2 )
  236.            {    name_type = try_number = 0;
  237.             goto try_funny_name;
  238.            }
  239.         /* falls through */
  240.     case ')':
  241.         retcode = e_syntaxerror;
  242.         break;
  243.     case '}':
  244.         if ( pstack == 0 )
  245.            {    retcode = e_syntaxerror;
  246.             break;    
  247.            }
  248.            {    ref *ref0 = (ref *)(proc_da.base + pstack);
  249.             uint size = myref - ref0;
  250.             ref *aref;
  251.             myref = ref0 - 1;
  252.             pstack = r_size(myref);
  253.             if ( pstack == 0 ) myref = pref;
  254.             if ( array_packing.value.index )
  255.                {    retcode = make_packed_array(ref0, size, myref,
  256.                                 "scanner(packed)");
  257.                 if ( retcode < 0 ) return retcode;
  258.                 r_set_attrs(myref, a_executable);
  259.                }
  260.             else
  261.               {    aref = alloc_refs(size, "scanner(proc)");
  262.                 if ( aref == 0 ) return e_VMerror;
  263.                 refcpy_to_new(aref, ref0, size);
  264.                 make_tasv_new(myref, t_array, a_executable + a_all, size, refs, aref);
  265.               }
  266.            }
  267.         break;
  268.     case '/':
  269.         c = sgetc(s);
  270.         if ( c == '/' )
  271.            {    name_type = 2;
  272.             c = sgetc(s);
  273.            }
  274.         else
  275.             name_type = 1;
  276.         try_number = 0;
  277.         switch ( decoder[c] )
  278.            {
  279.         case ctype_name:
  280.         default:
  281.             goto do_name;
  282.         case ctype_btoken:
  283.             if ( !recognize_btokens() ) goto do_name;
  284.             /* otherwise, an empty name */
  285.             sputback(s);
  286.         case ctype_eof:
  287.             /* Empty name: bizarre but legitimate. */
  288.             name_ref((byte *)0, 0, myref, 1);
  289.             goto have_name;
  290.         case ctype_other:
  291.             switch ( c )
  292.                {
  293.             case '[':    /* only special as first character */
  294.             case ']':    /* ditto */
  295.                 s1[0] = (byte)c;
  296.                 name_ref(s1, 1, myref, 1);
  297.                 goto have_name;
  298.             case '<':    /* legal in Level 2 */
  299.             case '>':
  300.                 if ( scan_enable_level2 ) goto try_funny_name;
  301.             default:
  302.                 /* Empty name: bizarre but legitimate. */
  303.                 name_ref((byte *)0, 0, myref, 1);
  304.                 sputback(s);
  305.                 goto have_name;
  306.                }
  307.         case ctype_space:
  308.             /* Empty name: bizarre but legitimate. */
  309.             name_ref((byte *)0, 0, myref, 1);
  310.             /* Check for \r\n */
  311.             if ( c == '\r' && (c = sgetc(s)) != '\n' && c != EOFC )
  312.                 sputback(s);
  313.             goto have_name;
  314.            }
  315.         /* NOTREACHED */
  316.     case '%':
  317.        {    for ( ; ; )
  318.           switch ( sgetc(s) )
  319.            {
  320.         case '\r':
  321.             if ( (c = sgetc(s)) != '\n' && c != EOFC )
  322.                 sputback(s);
  323.             /* falls through */
  324.         case '\n': case '\f':
  325.             goto top;
  326.         case EOFC:
  327.             goto ceof;
  328.            }
  329. ceof:        ;
  330.        }    /* falls through */
  331.     case EOFC:
  332.         retcode = (pstack != 0 ? e_syntaxerror : 1);
  333.         break;
  334.  
  335.     /* Check for a Level 2 funny name (<< or >>). */
  336.     /* c is '<' or '>'. */
  337. try_funny_name:
  338.        {    int c1 = sgetc(s);
  339.         if ( c1 == c )
  340.            {    s1[0] = s1[1] = c;
  341.             retcode = name_ref(s1, 2, myref, 1);
  342.             goto have_name;
  343.            }
  344.         if ( c1 != EOFC ) sputback(s);
  345.        }    retcode = e_syntaxerror;
  346.         break;
  347.  
  348.     /* Handle separately the names that might be a number */
  349.     case '0': case '1': case '2': case '3': case '4':
  350.     case '5': case '6': case '7': case '8': case '9':
  351.     case '.': case '+': case '-':
  352.         name_type = 0;
  353.         try_number = 1;
  354.         goto do_name;
  355.  
  356.     /* Check for a binary object */
  357. #define case4(c) case c: case c+1: case c+2: case c+3
  358.     case4(128): case4(132): case4(136): case4(140):
  359.     case4(144): case4(148): case4(152): case4(156):
  360. #undef case4
  361.         if ( recognize_btokens() )
  362.            {    retcode = (*scan_btoken_proc)(s, myref, c);
  363.             break;
  364.            }
  365.     /* Not a binary object, fall through. */
  366.  
  367.     /* The default is a name. */
  368.     default:
  369.     /* Handle the common cases (letters and _) explicitly, */
  370.     /* rather than going through the default test. */
  371.     case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
  372.     case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm':
  373.     case 'n': case 'o': case 'p': case 'q': case 'r': case 's':
  374.     case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z':
  375.     case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
  376.     case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M':
  377.     case 'N': case 'O': case 'P': case 'Q': case 'R': case 'S':
  378.     case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z':
  379.     case '_':
  380.         /* Common code for scanning a name. */
  381.         /* try_number and name_type are already set. */
  382.         /* We know c has ctype_name (or maybe ctype_btoken) */
  383.         /* or is a digit. */
  384.         name_type = 0;
  385.         try_number = 0;
  386. do_name:
  387.        {    dynamic_area da;
  388.         int max_name_ctype =
  389.             (recognize_btokens() ? ctype_name : ctype_btoken);
  390.         /* Try to scan entirely within the stream buffer. */
  391.         /* We stop 1 character early, so we don't switch buffers */
  392.         /* looking ahead if the name is terminated by \r\n. */
  393.         register byte *ptr = sbufptr(s);
  394.         byte *end = sbufend(s) - 1;
  395.         da.base = ptr - 1;
  396.         da.is_dynamic = 0;
  397.         do
  398.            {    if ( ptr >= end )
  399.                {    ssetbufptr(s, ptr);
  400.                 /* Initialize the dynamic area. */
  401.                 /* We have to do this before the next */
  402.                 /* sgetc, which will overwrite the buffer. */
  403.                 da.limit = ptr;
  404.                 da.num_elts = ptr - da.base;
  405.                 da.elt_size = 1;
  406.                 ptr = dynamic_grow(&da, ptr);
  407.                 if ( !ptr ) return e_VMerror;
  408.                 goto dyn_name;
  409.                }
  410.             c = *ptr++;
  411.            }
  412.         while ( decoder[c] <= max_name_ctype );    /* digit or name */
  413.         /* Name ended within the buffer. */
  414.         ssetbufptr(s, ptr);
  415.         ptr--;
  416.         goto nx;
  417.         /* Name overran buffer. */
  418. dyn_name:    while ( decoder[c = sgetc(s)] <= max_name_ctype )
  419.           {    if ( ptr == da.limit )
  420.                {    ptr = dynamic_grow(&da, ptr);
  421.                 if ( !ptr ) return e_VMerror;
  422.                }
  423.             *ptr++ = c;
  424.            }
  425. nx:        switch ( decoder[c] )
  426.           {
  427.           case ctype_btoken:
  428.           case ctype_other:
  429.             sputback(s);
  430.             break;
  431.           case ctype_space:
  432.             /* Check for \r\n */
  433.             if ( c == '\r' && (c = sgetc(s)) != '\n' && c != EOFC )
  434.                 sputback(s);
  435.           case ctype_eof: ;
  436.           }
  437.         /* Check for a number */
  438.         if ( try_number )
  439.            {    retcode = scan_number(da.base, ptr, myref);
  440.             if ( retcode != e_syntaxerror )
  441.                {    dynamic_free(&da);
  442.                 if ( name_type == 2 ) return e_syntaxerror;
  443.                 break;    /* might be e_limitcheck */
  444.                }
  445.            }
  446.         retcode = name_ref(da.base, (uint)(ptr - da.base), myref, 1);
  447.         dynamic_free(&da);
  448.        }
  449.         /* Done scanning.  Check for preceding /'s. */
  450. have_name:    if ( retcode < 0 ) return retcode;
  451.         switch ( name_type )
  452.            {
  453.         case 0:            /* ordinary executable name */
  454.             if ( r_has_type(myref, t_name) )    /* i.e., not a number */
  455.               r_set_attrs(myref, a_executable);
  456.         case 1:            /* quoted name */
  457.             break;
  458.         case 2:            /* immediate lookup */
  459.            {    ref *pvalue;
  460.             if ( !r_has_type(myref, t_name) )
  461.                 return e_undefined;
  462.             if ( (pvalue = dict_find_name(myref)) == 0 )
  463.                 return e_undefined;
  464.             ref_assign_new(myref, pvalue);
  465.            }
  466.            }
  467.        }
  468.     /* If we are at the top level, return the object, */
  469.     /* otherwise keep going. */
  470.     if ( pstack == 0 || retcode < 0 )
  471.       return retcode;
  472.     if ( proc_da.limit - (byte *)myref < 2 * sizeof(ref) )
  473.       return e_limitcheck; /* ****** SHOULD GROW OSTACK ****** */
  474.     myref++;
  475.     goto top;
  476. }
  477.  
  478. /* The internal scanning procedures return 0 on success, */
  479. /* or a (negative) error code on failure. */
  480.  
  481. /* Scan a number for cvi or cvr. */
  482. /* The first argument is a t_string.  This is just like scan_number, */
  483. /* but allows leading or trailing whitespace. */
  484. int
  485. scan_number_only(ref *psref, ref *pnref)
  486. {    byte *str = psref->value.bytes;
  487.     byte *end = str + r_size(psref);
  488.     if ( !r_has_attr(psref, a_read) ) return e_invalidaccess;
  489.     while ( str < end && scan_char_decoder[*str] == ctype_space )
  490.       str++;
  491.     while ( str < end && scan_char_decoder[end[-1]] == ctype_space )
  492.       end--;
  493.     return scan_number(str, end, pnref);
  494. }
  495.  
  496. /* Note that the number scanning procedures use a byte ** and a byte * */
  497. /* rather than a stream.  (It makes quite a difference in performance.) */
  498. #define ngetc(sp) (sp < end ? *sp++ : EOFC)
  499. #define nputback(sp) (--sp)
  500. #define nreturn(v) return (*pstr = sp, v)
  501.  
  502. /* Procedure to scan a number. */
  503. private int
  504. scan_number(byte *str, byte *end, ref *pref)
  505. {    /* Powers of 10 up to 6 can be represented accurately as */
  506.     /* a single-precision float. */
  507. #define num_powers_10 6
  508.     static float powers_10[num_powers_10+1] =
  509.        {    1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6    };
  510.     static double neg_powers_10[num_powers_10+1] =
  511.        {    1e0, 1e-1, 1e-2, 1e-3, 1e-4, 1e-5, 1e-6    };
  512.     byte *sp = str;        /* can't be register because of & */
  513.     int sign = 0;
  514.     long ival;
  515.     double dval;
  516.     int exp10 = 0;
  517.     int code;
  518.     register int c;
  519.     switch ( c = ngetc(sp) )
  520.        {
  521.     case '+': sign = 1; c = ngetc(sp); break;
  522.     case '-': sign = -1; c = ngetc(sp); break;
  523.        }
  524.     if ( !isdigit(c) )
  525.        {    if ( c != '.' ) return(e_syntaxerror);
  526.         c = ngetc(sp);
  527.         if ( !isdigit(c) ) return(e_syntaxerror);
  528.         ival = 0;
  529.         goto fi;
  530.        }
  531.     nputback(sp);
  532.     if ( (code = scan_int(&sp, end, 10, 0, &ival, &dval)) != 0 )
  533.        {    if ( code < 0 ) return(code);    /* e_syntaxerror */
  534.         /* Code == 1, i.e., the integer overflowed. */
  535.         switch ( c = ngetc(sp) )
  536.            {
  537.         default: return(e_syntaxerror); /* not terminated properly */
  538.         case '.': c = ngetc(sp); goto fd;
  539.         case 'e': case 'E': goto fsd;
  540.         case EOFC:        /* return a float */
  541.             make_real_new(pref, (float)(sign < 0 ? -dval : dval));
  542.             return(0);
  543.            }
  544.        }
  545.     switch ( c = ngetc(sp) )
  546.        {
  547.     case EOFC: break;
  548.     case '.': c = ngetc(sp); goto fi;
  549.     default: return(e_syntaxerror);    /* not terminated properly */
  550.     case 'e': case 'E': goto fsi;
  551.     case '#':
  552.         if ( sign || ival < min_radix || ival > max_radix )
  553.             return(e_syntaxerror);
  554.         code = scan_int(&sp, end, (int)ival, 1, &ival, NULL);
  555.         if ( code ) return(code);
  556.         if ( ngetc(sp) != EOFC ) return(e_syntaxerror);
  557.        }
  558.     /* Return an integer */
  559.     make_int_new(pref, (sign < 0 ? -ival : ival));
  560.     return(0);
  561.     /* Handle a real.  We just saw the decimal point. */
  562.     /* Enter here if we are still accumulating an integer in ival. */
  563. fi:    while ( isdigit(c) )
  564.        {    /* Check for overflowing ival */
  565.         if ( ival >= (max_ulong >> 1) / 10 - 1 )
  566.            {    dval = ival;
  567.             goto fd;
  568.            }
  569.         ival = ival * 10 + (c - '0');
  570.         c = ngetc(sp);
  571.         exp10--;
  572.        }
  573. fsi:    if ( sign < 0 ) ival = -ival;
  574.     /* Take a shortcut for the common case */
  575.     if ( !(c == 'e' || c == 'E' || exp10 < -num_powers_10) )
  576.        {    make_real_new(pref, (float)(ival * neg_powers_10[-exp10]));
  577.         return(0);
  578.        }
  579.     dval = ival;
  580.     goto fe;
  581.     /* Now we are accumulating a double in dval. */
  582. fd:    while ( isdigit(c) )
  583.        {    dval = dval * 10 + (c - '0');
  584.         c = ngetc(sp);
  585.         exp10--;
  586.        }
  587. fsd:    if ( sign < 0 ) dval = -dval;
  588. fe:    /* dval contains the value, negated if necessary */
  589.     if ( c == 'e' || c == 'E' )
  590.        {    /* Check for a following exponent. */
  591.         int esign = 0;
  592.         long eexp;
  593.         switch ( c = ngetc(sp) )
  594.            {
  595.         case '+': break;
  596.         case '-': esign = 1; break;
  597.         default: nputback(sp);
  598.            }
  599.         code = scan_int(&sp, end, 10, 0, &eexp, NULL);
  600.         if ( code < 0 ) return(code);
  601.         if ( code > 0 || eexp > 999 )
  602.             return(e_limitcheck);    /* semi-arbitrary */
  603.         if ( esign )
  604.             exp10 -= (int)eexp;
  605.         else
  606.             exp10 += (int)eexp;
  607.         c = ngetc(sp);
  608.        }
  609.     if ( c != EOFC ) return(e_syntaxerror);
  610.     /* Compute dval * 10^exp10. */
  611.     if ( exp10 > 0 )
  612.        {    while ( exp10 > num_powers_10 )
  613.             dval *= powers_10[num_powers_10],
  614.             exp10 -= num_powers_10;
  615.         if ( exp10 > 0 )
  616.             dval *= powers_10[exp10];
  617.        }
  618.     else if ( exp10 < 0 )
  619.        {    while ( exp10 < -num_powers_10 )
  620.             dval /= powers_10[num_powers_10],
  621.             exp10 += num_powers_10;
  622.         if ( exp10 < 0 )
  623.             dval /= powers_10[-exp10];
  624.        }
  625.     make_real_new(pref, (float)dval);
  626.     return(0);
  627. }
  628. /* Internal subroutine to scan an integer. */
  629. /* Return 0, e_limitcheck, or e_syntaxerror. */
  630. /* (The only syntax error is no digits encountered.) */
  631. /* Put back the terminating character. */
  632. /* If nosign is true, the integer is scanned as unsigned; */
  633. /* overflowing a ulong returns e_limitcheck.  If nosign is false, */
  634. /* the integer is scanned as signed; if the integer won't fit in a long, */
  635. /* then: */
  636. /*   if pdval == NULL, return e_limitcheck; */
  637. /*   if pdval != NULL, return 1 and store a double value in *pdval. */
  638. private int
  639. scan_int(byte **pstr, byte *end, int radix, int nosign,
  640.   long *pval, double *pdval)
  641. {    register byte *sp = *pstr;
  642.     uint ival = 0, imax, irem;
  643. #if arch_ints_are_short
  644.     ulong lval, lmax;
  645.     uint lrem;
  646. #else
  647. #  define lval ival            /* for overflowing into double */
  648. #endif
  649.     double dval;
  650.     register int c, d;
  651.     register byte _ds *decoder = scan_char_decoder;
  652.     /* Avoid the long divisions when radix = 10 */
  653. #define set_max(vmax, vrem, big)\
  654.   if ( radix == 10 )    vmax = (big) / 10, vrem = (big) % 10;\
  655.   else            vmax = (big) / radix, vrem = (big) % radix
  656.     set_max(imax, irem, max_uint);
  657. #define convert_digit_fails(c, d)\
  658.   (d = decoder[c]) >= radix
  659.     while ( 1 )
  660.        {    c = ngetc(sp);
  661.         if ( convert_digit_fails(c, d) )
  662.            {    if ( c != EOFC ) nputback(sp);
  663.             if ( (int)ival < 0 && !nosign )
  664.                {    d = ival % radix;
  665.                 ival /= radix;
  666.                 break;
  667.                }
  668.             *pval = ival;
  669.             nreturn(0);
  670.            }
  671.         if ( ival >= imax && (ival > imax || d > irem) )
  672.             break;        /* overflow */
  673.         ival = ival * radix + d;
  674.        }
  675. #if arch_ints_are_short
  676.     /* Short integer overflowed.  Accumulate in a long. */
  677.     lval = (ulong)ival * radix + d;
  678.     set_max(lmax, lrem, max_ulong);
  679.     while ( 1 )
  680.        {    c = ngetc(sp);
  681.         if ( convert_digit_fails(c, d) )
  682.            {    if ( c != EOFC ) nputback(sp);
  683.             if ( (long)lval < 0 && !nosign )
  684.                {    d = lval % radix;
  685.                 lval /= radix;
  686.                 break;
  687.                }
  688.             *pval = lval;
  689.             nreturn(0);
  690.            }
  691.         if ( lval >= lmax && (lval > lmax || d > lrem) )
  692.             break;        /* overflow */
  693.         lval = lval * radix + d;
  694.        }
  695. #endif
  696.     /* Integer overflowed.  Accumulate the result as a double. */
  697.     if ( pdval == NULL ) nreturn(e_limitcheck);
  698.     dval = (double)lval * radix + d;
  699.     while ( 1 )
  700.        {    c = ngetc(sp);
  701.         if ( convert_digit_fails(c, d) )
  702.            {    if ( c != EOFC ) nputback(sp);
  703.             *pdval = dval;
  704.             nreturn(1);
  705.            }
  706.         dval = dval * radix + d;
  707.        }
  708.     /* Control doesn't get here */
  709. }
  710.  
  711. /* Make a string.  If the allocation fails, release any dynamic storage. */
  712. private int
  713. mk_string(ref *pref, da_ptr pda, byte *next)
  714. {    uint size = (pda->next = next) - pda->base;
  715.     byte *body = alloc_shrink(pda->base, pda->num_elts, size, 1, "scanner(string)");
  716.     if ( body == 0 )
  717.        {    dynamic_free(pda);
  718.         return e_VMerror;
  719.        }
  720.     make_tasv_new(pref, t_string, a_all, size, bytes, body);
  721.     return 0;
  722. }
  723.  
  724. /* Internal procedure to scan a string. */
  725. private int
  726. scan_string(register stream *s, int from_string, ref *pref)
  727. {    dynamic_area da;
  728.     register int c;
  729.     register byte *ptr = dynamic_begin(&da, 100, 1);
  730.     int plevel = 0;
  731.     if ( ptr == 0 ) return e_VMerror;
  732. top:    while ( 1 )
  733.        {    switch ( (c = sgetc(s)) )
  734.            {
  735.         case EOFC:
  736.             dynamic_free(&da);
  737.             return e_syntaxerror;
  738.         case '\\':
  739.             if ( from_string ) break;
  740.             switch ( (c = sgetc(s)) )
  741.                {
  742.             case 'n': c = '\n'; break;
  743.             case 'r': c = '\r'; break;
  744.             case 't': c = '\t'; break;
  745.             case 'b': c = '\b'; break;
  746.             case 'f': c = '\f'; break;
  747.             case '\r':    /* ignore, check for following \n */
  748.                 c = sgetc(s);
  749.                 if ( c != '\n' && c != EOFC )
  750.                     sputback(s);
  751.                 goto top;
  752.             case '\n': goto top;    /* ignore */
  753.             case '0': case '1': case '2': case '3':
  754.             case '4': case '5': case '6': case '7':
  755.                {    int d = sgetc(s);
  756.                 c -= '0';
  757.                 if ( d >= '0' && d <= '7' )
  758.                    {    c = (c << 3) + d - '0';
  759.                     d = sgetc(s);
  760.                     if ( d >= '0' && d <= '7' )
  761.                        {    c = (c << 3) + d - '0';
  762.                         break;
  763.                        }
  764.                    }
  765.                 if ( d == EOFC )
  766.                    {    dynamic_free(&da);
  767.                     return e_syntaxerror;
  768.                    }
  769.                 sputback(s);
  770.                }
  771.                 break;
  772.             default: ;    /* ignore the \ */
  773.                }
  774.             break;
  775.         case '(':
  776.             plevel++; break;
  777.         case ')':
  778.             if ( --plevel < 0 ) goto out; break;
  779.         case '\r':        /* convert to \n */
  780.             c = sgetc(s);
  781.             if ( c != '\n' && c != EOFC )
  782.                 sputback(s);
  783.             c = '\n';
  784.            }
  785.         if ( ptr == da.limit )
  786.            {    ptr = dynamic_grow(&da, ptr);
  787.             if ( !ptr ) return e_VMerror;
  788.            }
  789.         *ptr++ = c;
  790.        }
  791. out:    return mk_string(pref, &da, ptr);
  792. }
  793.  
  794. /* Internal procedure to scan a hex string. */
  795. private int
  796. scan_hex_string(stream *s, ref *pref)
  797. {    dynamic_area da;
  798.     int c1, c2, val1, val2;
  799.     byte *ptr = dynamic_begin(&da, 100, 1);
  800.     register byte _ds *decoder = scan_char_decoder;
  801.     if ( ptr == 0 ) return e_VMerror;
  802. l1:    do
  803.        {    c1 = sgetc(s);
  804.         if ( (val1 = decoder[c1]) < 0x10 )
  805.            {    do
  806.                {    c2 = sgetc(s);
  807.                 if ( (val2 = decoder[c2]) < 0x10 )
  808.                    {    if ( ptr == da.limit )
  809.                        {    ptr = dynamic_grow(&da, ptr);
  810.                         if ( !ptr ) return e_VMerror;
  811.                        }
  812.                     *ptr++ = (val1 << 4) + val2;
  813.                     goto l1;
  814.                    }
  815.                }
  816.             while ( val2 == ctype_space );
  817.             if ( c2 != '>' )
  818.                {    dynamic_free(&da);
  819.                 return e_syntaxerror;
  820.                }
  821.             if ( ptr == da.limit )
  822.                {    ptr = dynamic_grow(&da, ptr);
  823.                 if ( !ptr ) return e_VMerror;
  824.                }
  825.             *ptr++ = val1 << 4;    /* no 2nd char */
  826.             goto lx;
  827.            }
  828.        }
  829.     while ( val1 == ctype_space );
  830.     if ( c1 != '>' )
  831.        {    dynamic_free(&da);
  832.         return e_syntaxerror;
  833.        }
  834. lx:    return mk_string(pref, &da, ptr);
  835. }
  836.